
; QUAL.LISP  Copyright (C) Patrick W. Langley 2009

; *** Still need to implement the commands: 
;     group (and adapt disable/enable to handle) 
;     ungroup
;     save (and make entries/answers uniform)
;     help

; The PLACE structure specifies some place (e.g., the lysosome
; or mitochondria) and a possibly empty location (e.g., the cell). 
; and phenomena. 

(defstruct place id name in note)

; The QUANTITY structure includes fields for the quantity's ID and NAME, 
; both arbitrary atoms, for its location (IN, which must be some 
; declared place), and for its type (STABLE or UNSTABLE). These 
; structures form the building blocks of claims, predictions, 
; and facts. There is also a NOTE field, which is possibly empty 
; list that describes the quantity. 

(defstruct quantity id name type in note) 

; The CLAIM structure specifies a causal link between two variables. 
; The fields CAUSE and EFFECT can be any quantity ids, DIRECTION can 
; be INCREASES or DECREASES, and NOTE can be any list, including NIL, 
; that describes the relationship. 
; E.g., (make-claim :id p3 :cause e1 :effect e3 :direction increases). 
; Note: The CAUSE field may be NULL for exogenous variables. 

(defstruct claim id cause effect direction note)

; The FACT structure specifies an observed relationship between two 
; quantities. E.g., (make-fact :id f1 :from Fe :to Junk :direction) 
; states that, if one increases Fe, one observes an increase in Junk. 
; The first argument may also be TIME, in which case the structure 
; describes how the second argument varies with time. 

(defstruct fact id from to direction note) 

; The PREDICTION structure takes the same form as a FACT, except 
; that it lacks the NOTE field. Predictions are generated by the
; system for comparison with facts, so the latter is unnecessary. 

(defstruct prediction id from to direction paths) 

(defvar places* nil)
(defvar quantities* nil) 
(defvar claims* nil) 
(defvar facts* nil)
(defvar predictions* nil)
(defvar disabled-claims* nil)
(defvar disabled-facts* nil)
(defvar latest-id* nil)
(defvar loading* nil)
(defvar commands* nil)

(setq places* nil)
(setq quantities* nil) 
(setq claims* nil) 
(setq facts* nil)
(setq predictions* nil)
(setq disabled-claims* nil)
(setq disabled-facts* nil)
(setq loading* nil)
(setq commands*
      '(place transient stable claim fact show does predict explain disable
	      enable remove load save help quit))

; Declare the special "quantity" time, which has no location. 

(make-quantity :id 'time :name 'time :in nil)

; **********************************************************************
; Top-level functions for interacting with the user
; **********************************************************************

(defun run ()
  (do ((input (prompt-and-input) (prompt-and-input)))
      ((member (car input) '(quit q exit bye end halt done))
       (princ "Goodbye.") nil)
      (let ((command (car input))
	    (rest (cdr input)))
	(cond ((or (null command) (eq '% (car input))) nil)
	      ((eq command 'place)(create-place rest))
              ((eq command 'transient)(create-quantity rest 'transient))
              ((eq command 'stable)(create-quantity rest 'stable))
	      ((eq command 'claim)(create-claim rest))
	      ((eq command 'fact)(create-fact rest))
	      ((eq command 'does)(ask-query rest))
	      ((eq command 'note)(add-note rest))
	      ((eq command 'show)(show-content rest))
	      ((eq command 'predict)(show-predict rest))
	      ((eq command 'explain)(show-explain rest))
	      ((eq command 'remove)(remove-content rest))
	      ((eq command 'disable)(disable-content rest))
	      ((eq command 'enable)(enable-content rest))
	      ((eq command 'group)(create-group rest))
	      ((eq command 'ungroup)(uncreate-group rest))
	      ((eq command 'load)(mapc #'load-content rest))
	      ((eq command 'save)(save-content rest))
	      ((member command '(help h ?))(provide-help rest))
	      (t (say-not-command command))))))

(defun say-not-command (command)
  (say command)
  (princ " is not one of the valid commands: place, transient, stable, claim,")
  (saycr " fact, show, does, predict, explain, disable, enable, remove, load,")
  (saycr " save, or help.")
  (terpri) nil)

; **********************************************************************
; Creation functions that add contents to memory
; **********************************************************************

(defun create-place (place)
  (let ((loc nil)(loc-id nil)(in nil)(in-id nil))
    (setq loc (pop place))
    (cond ((and (not (null place))
                (eq (car place) 'in)
                (eq (cadr place) 'the))
           (setq in (caddr place))
	   (setq in-id (get-place in places*))
	   (setq place (cdddr place))))
    (cond ((and (not (null in)) (null in-id))
	   (say-not-declared in 'place) nil)
	  ((not (null place))
	   (say "Place specifications take the form: ")
   	   (saycr "<new-place> (in the <existing-place>)")
	   (terpri) nil)
	  (t (setq loc-id (gen-name 'l))
	     (setq latest-id* loc-id)
	     (push (make-place :id loc-id :name loc :in in-id) places*)
	     (cond ((null loading*)
		    (show-place (car places*))(terpri)))
	     nil))))

(defun get-place (place places)
  (let ((result nil))
    (do ((next (car places) (car places)))
	((or (null places) (not (null result))) result)
	(cond ((eq (place-name next) place)
	       (setq result (place-id next))))
	(pop places))))

(defun say-not-declared (thing type)
  (saycr "You must declare the ")(princ type)(princ " ")
  (princ thing)(princ " before you refer to it.") nil)

(defun create-quantity (quantity type)
  (let ((id nil)(name nil)(in nil))
    (setq name (pop quantity))
    (cond ((null quantity)
	   (saycr "You must specify at least one place where the
                   quantity occurs.") nil)
	  (t (do ()
		 ((null quantity) nil)
		 (cond ((and (eq (car quantity) 'in)
			     (eq (cadr quantity) 'the))
			(setq in (caddr quantity))
			(setq in-id (get-place in places*))
			(setq quantity (cdddr quantity)))
		       ((not (null quantity))
			(say-quantity-format) nil))
		 (cond ((and (not (null in)) (null in-id))
			(say-not-declared in 'place) nil)
		       (t (setq id (gen-name 'q))
			  (setq latest-id* id)
			  (push (make-quantity :id id :name name
					       :in in-id :type type)
				quantities*)
			  (cond ((null loading*)
				 (show-quantity (car quantities*))(terpri)))))
		 (cond ((and (not (null quantity))
			     (eq (car quantity) 'and))
			(pop quantity))))))))

(defun say-quantity-format ()
  (say "Quantity specifications take the form: ")
; (saycr "<quantity> (occurs in the <place1> (and in the <place2> ...))")
  (saycr "<quantity> (in the <place1> (and in the <place2> ...))")
  nil)

; CREATE-CLAIM inputs a list that specifies a hypothesized relation
; between two quantities. This should take the form: 
; (<quantity1> in the <place1> <direction> with <quantity2> in the <place2>)
; or 
; (<quantity1> <direction> with <quantity2> in the <place2>)
; where <direction> is INCREASES or DECREASES and where the places and
; quantities have already been declared. 
; If the list obeys these constraints, the function creates a CLAIM
; structure that incorporates the specified content and add it to 
; the CLAIMS* list. 

; *** Need to support an optional claim id before to-name, which
;     is needed when loading in files saved from an earlier run. 

(defun create-claim (claim)
  (let ((to-name nil)(to-loc nil)(to-id nil)(from-name nil)
	(from-loc nil)(from-id nil)(direction nil)(id nil)(error nil))
    (cond ((null (get-quantities (car claim) quantities*))
	   (setq id (pop claim))))
    (setq to-name (pop claim))
    (cond ((and (eq (car claim) 'in)
		(eq (cadr claim) 'the))
	   (setq to-loc (caddr claim))
	   (setq claim (cdddr claim))))
    (cond ((or (eq (car claim) 'increases)
	       (eq (car claim) 'decreases))
	   (setq direction (pop claim)))
	  (t (say-claim-format (car claim))
	     (setq error t)))
    (cond ((and (null error) (eq (car claim) 'with))
	   (pop claim))
	  (t (say-claim-format (car claim))
	     (setq error t)))
    (setq from-name (pop claim))
    (cond ((and (null error)
		(eq (car claim) 'in)
		(eq (cadr claim) 'the))
	   (setq from-loc (caddr claim))
	   (setq claim (cdddr claim))
	   (cond ((null to-loc)
		  (setq to-loc from-loc)))))
    (cond ((and (null error) (not (null claim)))
	   (say-claim-format (car claim))
	   (setq error t)))
    (cond ((and (null error)
		(null (get-quantity-in to-name to-loc))
		(null (get-claim-by-id to-name claims*)))
	   (princ "You have not declared ")(princ to-name)
	   (say " to occur in the ")(princ to-loc)(princ ".")
	   (terpri))
	  ((and (null error)
		(null (get-quantity-in from-name from-loc)))
	   (say "You have not declared ")(princ from-name)
	   (say " to occur in the ")(princ from-loc)(princ ".")
	   (terpri))
	  ((null error)
	   (cond ((not (null (get-claim-by-id to-name claims*)))
		  (setq to-id to-name))
		 (t (setq to-id
			  (quantity-id (get-quantity-in to-name to-loc)))))
	   (setq from-id
		 (quantity-id (get-quantity-in from-name from-loc)))
	   (cond ((null id) (setq id (gen-name 'c))))
	   (setq latest-id* id)
	   (push (make-claim :id id :cause from-id :effect to-id
			     :direction direction) claims*)
	   (cond ((null loading*)
		  (show-claim (car claims*))(terpri)))))
    nil))

(defun create-fact (fact)
  (let ((to-name nil)(to-loc nil)(to-id nil)(from-name nil)
	(from-loc nil)(from-id nil)(direction nil)(id nil)(error nil))
    (cond ((null (get-quantities (car fact) quantities*))
	   (setq id (pop fact))))
    (setq to-name (pop fact))
    (cond ((and (eq (car fact) 'in)
		(eq (cadr fact) 'the))
	   (setq to-loc (caddr fact))
	   (setq fact (cdddr fact))))
    (cond ((or (eq (car fact) 'increases)
	       (eq (car fact) 'decreases)
	       (eq (car fact) 'does-not-change)
	       (eq (car fact) 'does-not-vary))
	   (setq direction (pop fact)))
	  (t (say-fact-format (car fact))
	     (setq error t)))
    (cond ((and (null error) (eq (car fact) 'with))
	   (pop fact))
	  (t (say-fact-format (car fact))
	     (setq error t)))
    (setq from-name (pop fact))
    (cond ((and (null error)
		(eq (car fact) 'in)
		(eq (cadr fact) 'the))
	   (setq from-loc (caddr fact))
	   (setq fact (cdddr fact))
	   (cond ((null to-loc)
		  (setq to-loc from-loc)))))
    (cond ((and (null error) (not (null fact)))
	   (say-fact-format (car fact))
	   (setq error t)))
    (cond ((and (null error)
		(null (get-quantity-in to-name to-loc)))
	   (say "You have not declared ")(princ to-name)
	   (say " to occur in the ")(princ to-loc)(princ ".")
	   (terpri))
	  ((and (null error)
		(not (eq from-name 'time))
		(null (get-quantity-in from-name from-loc)))
	   (say "You have not declared ")(princ from-name)
	   (say " to occur in the ")(princ from-loc)(princ ".")
	   (terpri))
	  ((null error)
	   (setq to-id (quantity-id (get-quantity-in to-name to-loc)))
	   (setq from-id
		 (quantity-id (get-quantity-in from-name from-loc)))
	   (cond ((null id) (setq id (gen-name 'f))))
	   (setq latest-id* id)
	   (push (make-fact :id id :from from-id :to to-id
			    :direction direction) facts*)
	   (cond ((null loading*)
		  (show-fact (car facts*))(terpri)))))
    nil))

(defun get-quantity-in (quantity place)
  (let ((quantities nil)(result nil))
    (setq quantities (get-quantities quantity quantities*))
    (do ((next (car quantities) (car quantities)))
	((or (null quantities) (not (null result))) result)
	(cond ((eq (get-place-name-by-id (quantity-in next) places*) place)
	       (setq result next)))
	(pop quantities))))

(defun get-quantities (quantity quantities)
  (let ((result nil))
    (do ((next (car quantities) (car quantities)))
	((null quantities) result)
	(cond ((eq (quantity-name next) quantity)
	       (push next result)))
	(pop quantities))))

(defun get-place-name-by-id (id places)
  (let ((result nil))
    (do ((next (car places) (car places)))
	((or (null places) (not (null result))) result)
	(cond ((eq (place-id next) id)
	       (setq result (place-name next))))
	(pop places))))

(defun say-claim-format (word)
  (say "Claims take the form: ")
  (saycr "<quantity1> in the <location1> increases (decreases)")
  (saycr "with <quantity2> in the <location2>")
  (saycr "Your statement diverged at: ")
  (princ word) nil)

(defun say-fact-format (word)
  (say "Facts take the form: ")
  (saycr "<quantity1> in the <location1> increases/decreases/does-not-change")
  (saycr "with <quantity2> in the <location2>")
  (saycr "Your statement diverged at: ")
  (princ word) nil)

; The ADD-NOTE function that associates a note with a given structure
; to elaborate on its intent. If the user specifies the id for the
; structure to be commented on, it uses that; otherwise, it uses
; the most recently generated id. 

(defun add-note (note)
  (let ((struct (get-struct-by-id (car note))))
    (cond ((null struct)
	   (setq struct (get-struct-by-id latest-id*)))
	  (t (pop note)))
    (cond ((eq (car struct) 'place)
	   (setf (place-note (cdr struct)) note))
	  ((eq (car struct) 'quantity)
	   (setf (quantity-note (cdr struct)) note))
	  ((eq (car struct) 'claim)
	   (setf (claim-note (cdr struct)) note))
	  ((eq (car struct) 'fact)
	   (setf (fact-note (cdr struct)) note)))
    nil))

(defun get-struct-by-id (id)
  (let ((struct nil))
    (cond ((setq struct (get-place-by-id id places*))
	   (cons 'place struct))
	  ((setq struct (get-quantity-by-id id quantities*))
	   (cons 'quantity struct))
	  ((setq struct (get-claim-by-id id claims*))
	   (cons 'claim struct))
	  ((setq struct (get-fact-by-id id facts*))
	   (cons 'fact struct))
	  (t nil))))

(defun get-place-by-id (id elements)
  (let ((result nil))
    (do ((next (car elements) (car elements)))
	((or (null elements) (not (null result))) result)
	(cond ((eq (place-id next) id)
	       (setq result next)))
	(pop elements))))

(defun get-quantity-by-id (id elements)
  (let ((result nil))
    (do ((next (car elements) (car elements)))
	((or (null elements) (not (null result))) result)
	(cond ((eq (quantity-id next) id)
	       (setq result next)))
	(pop elements))))

(defun get-claim-by-id (id elements)
  (let ((result nil))
    (do ((next (car elements) (car elements)))
	((or (null elements) (not (null result))) result)
	(cond ((eq (claim-id next) id)
	       (setq result next)))
	(pop elements))))

(defun get-fact-by-id (id elements)
  (let ((result nil))
    (do ((next (car elements) (car elements)))
	((or (null elements) (not (null result))) result)
	(cond ((eq (fact-id next) id)
	       (setq result next)))
	(pop elements))))

(defun get-prediction-by-id (id elements)
  (let ((result nil))
    (do ((next (car elements) (car elements)))
	((or (null elements) (not (null result))) result)
	(cond ((eq (prediction-id next) id)
	       (setq result next)))
	(pop elements))))

; **********************************************************************
; Display functions that show the contents of memory
; **********************************************************************

; SHOW-CONTENT inputs a list of types and prints out the instances
; of each type in a readable format. 

(defun show-content (types)
  (cond ((null types)
	 (setq types '(places quantities claims facts predictions))))
  (do ((next (car types) (car types)))
      ((null types) nil)
      (cond ((eq next 'places)(show-places))
	    ((eq next 'quantities)(show-quantities))
	    ((eq next 'claims)(show-claims))
	    ((eq next 'facts)(show-facts))
	    ((eq next 'predictions)(show-predictions)))
      (pop types)))

(defun show-places ()
  (cond ((not (null places*))
	 (princ "Places:")
	 (mapc #'(lambda (p) (terpri)(show-place p)) (reverse places*))
	 (terpri) nil)))

(defun show-place (place)
  (princ "  ")(princ (place-id place))
  (princ ": ")(princ (place-name place))
  (cond ((not (null (place-in place)))
	 (princ " in the ")
	 (princ (get-place-name-by-id (place-in place) places*))))
  (cond ((not (null (place-note place)))
	 (terpri)(princ "       [ ")
	 (mapc #'(lambda (n) (princ n)(princ " ")) (place-note place))
	 (princ "]"))))


(defun show-quantities ()
 (cond ((not (null quantities*))
        (princ "Quantities:")
        (mapc #'(lambda (e)
                  (cond ((not (eq (quantity-name e) 'time))
                         (terpri)(show-quantity e))))
              (reverse quantities*))
        (terpri) nil)))

;; GRH 2010-12-01
;; updated to hide time whenever quantities are displayed 
;;
;; (defun show-quantities ()
;;   (cond ((not (null quantities*))
;; 	 (princ "Quantities:")
;; 	 (mapc #'(lambda (e) (terpri)(show-quantity e))
;; 	       (reverse quantities*))
;; 	 (terpri) nil)))

(defun show-quantity (quantity)
;  (saycr "  ")(princ (quantity-id quantity))
  (princ "  ")(princ (quantity-id quantity))
  (princ ": ")(princ (quantity-type quantity))
  (princ " ")(princ (quantity-name quantity))
  (cond ((not (null (quantity-in quantity)))
	 (princ " in the ")
	 (princ (get-place-name-by-id (quantity-in quantity) places*))))
  (cond ((not (null (quantity-note quantity)))
	 (terpri)(princ "       [ ")
	 (mapc #'(lambda (n) (princ n)(princ " ")) (quantity-note quantity))
	 (princ "]"))))

; *******
; Refine show functions to print only quantities, claims, and facts
; related to a specified place. 

(defun show-claims ()
  (cond ((not (null claims*))
	 (princ "Hypothesized claims:")
	 (mapc #'(lambda (c) (terpri)(show-claim c)) (reverse claims*))
	 (terpri) nil)))

(defun show-claim (claim)
  (let* ((to nil)(to-name nil)(to-loc nil)
;	 (to (get-quantity-by-id (claim-effect claim) quantities*))
;	 (to-name (quantity-name to))
;	 (to-loc (get-place-name-by-id (quantity-in to) places*))
	 (from (get-quantity-by-id (claim-cause claim) quantities*))
	 (from-name (quantity-name from))
	 (from-loc (get-place-name-by-id (quantity-in from) places*)))
    (cond ((setq to (get-quantity-by-id (claim-effect claim) quantities*))
	   (setq to-name (quantity-name to))
	   (setq to-loc (get-place-name-by-id (quantity-in to) places*)))
	  (t (setq to (get-claim-by-id (claim-effect claim) claims*))
	     (setq to-name (claim-id to))))
    (princ "  ")(princ (claim-id claim))
    (princ ": ")(princ to-name)
    (cond ((and (not (null to-loc))
		(not (eq to-loc from-loc)))
	   (princ " in the ")(princ to-loc)))
    (princ " ")(princ (claim-direction claim))
    (princ " with ")(princ from-name)
    (cond ((not (null from-loc))
	   (princ " in the ")(princ from-loc)))
    (cond ((not (null (claim-note claim)))
	   (terpri)(princ "       [")
	   (princ (car (claim-note claim)))
	   (mapc #'(lambda (n) (princ " ")(princ n))
		 (cdr (claim-note claim)))
	   (princ "]")))))

(defun show-facts ()
  (cond ((not (null facts*))
	 (princ "Observed facts:")
	 (mapc #'(lambda (f) (terpri)(show-fact f)) (reverse facts*))
	 (terpri) nil)))

(defun show-fact (fact)
  (let* ((to (get-quantity-by-id (fact-to fact) quantities*))
	 (to-name (quantity-name to))
	 (to-loc (get-place-name-by-id (quantity-in to) places*))
	 (from (get-quantity-by-id (fact-from fact) quantities*))
	 (from-name (quantity-name from))
	 (from-loc (get-place-name-by-id (quantity-in from) places*)))
;    (saycr "  ")(princ (fact-id fact))
    (princ "  ")(princ (fact-id fact))
    (princ ": ")(princ to-name)
    (cond ((not (eq to-loc from-loc))
	   (princ " in the ")(princ to-loc)))
    (princ " ")(princ (fact-direction fact))
    (princ " with ")(princ from-name)
    (cond ((not (null from-loc))
	   (princ " in the ")(princ from-loc)))
    (cond ((not (null (fact-note fact)))
	   (terpri)(princ "       [ ")
	   (mapc #'(lambda (n) (princ n)(princ " "))
		 (fact-note fact))
	   (princ "]")))))

(defun show-predictions ()
  (cond ((not (null predictions*))
	 (princ "Predictions:")
	 (mapc #'(lambda (p) (terpri)(show-prediction p))
	       (reverse predictions*))
	 (terpri) nil)))

(defun get-quantity-by-id (id quantities)
  (let ((result nil))
    (do ((next (car quantities) (car quantities)))
	((or (null quantities) (not (null result))) result)
	(cond ((eq (quantity-id next) id)
	       (setq result next)))
	(pop quantities))))

(defun get-quantity-name-by-id (id quantities)
  (let ((result nil))
    (do ((next (car quantities) (car quantities)))
	((or (null quantities) (not (null result))) result)
	(cond ((eq (quantity-id next) id)
	       (setq result (quantity-name next))))
	(pop quantities))))

(defvar names* nil)
(setq names* nil)

; GEN-NAME generates a unique name that starts with TYPE.

(defun gen-name (type)
  (let ((pair (assoc type names*)))
    (cond ((null pair)
           (push (cons type 1) names*)
           (intern (concatenate 'string (string type)
                                (princ-to-string 1))))
          (t (setf (cdr pair) (1+ (cdr pair)))
             (intern (concatenate 'string (string type) 
                                  (princ-to-string (cdr pair))))))))

; **********************************************************************
; Functions for answering user queries
; **********************************************************************

; We need three high-level functions that (1) answer a specific 
; query about whether and how one variable influences another, 
; (2) collect the answers to queries that correspond to all known
; facts (phenomena), and (3) compare these predictions to the set 
; of phenomena. The latter can use the former as subroutines, 
; although more effective methods may be possible for each one. 

(defun ask-query (question)
  (let ((to-name nil)(to-loc nil)(to-ent nil)(from-name nil)
	(from-loc nil)(from-ent nil)(direction nil)(id nil)(error nil))
    (setq to-name (pop question))
    (cond ((and (eq (car question) 'in)
		(eq (cadr question) 'the))
	   (setq to-loc (caddr question))
	   (setq question (cdddr question))))
    (cond ((or (eq (car question) 'vary)
	       (eq (car question) 'change)
	       (eq (car question) 'increase)
	       (eq (car question) 'decrease))
	   (pop question))
	  (t (say-query-format (car question))
	     (setq error t)))
    (cond ((and (null error) (eq (car question) 'with))
	   (pop question))
	  ((null error)
           (say-query-format (car question))
           (setq error t)))
    (setq from-name (pop question))
    (cond ((and (null error)
		(eq (car question) 'in)
		(eq (cadr question) 'the))
	   (setq from-loc (caddr question))
	   (setq question (cdddr question))
	   (cond ((null to-loc)
		  (setq to-loc from-loc)))))
    (cond ((and (null error) (not (null question)))
	   (say-query-format (car question))
	   (setq error t)))
    (setq to-ent (get-quantity-in to-name to-loc))
    (setq from-ent (get-quantity-in from-name from-loc))
    (cond ((and (null error) (null to-ent))
	   (say "You have not declared ")(princ to-name)
	   (say " to occur in the ")(princ to-loc)(princ ".")
	   (terpri)(setq error t)))
    (cond ((and (null error) (null from-ent))
	   (say "You have not declared ")(princ from-name)
	   (say " to occur in the ")(princ from-loc)(princ ".")
	   (terpri)(setq error t)))
    (cond ((and (null error) (eq from-name 'time))
	   (show-prediction (tquery to-ent from-ent))(terpri))
	  ((null error)
	   (show-prediction (equery to-ent from-ent))(terpri)))
    nil))

(defun show-prediction (prediction)
  (let* ((to (get-quantity-by-id (prediction-to prediction) quantities*))
	 (to-ent (quantity-name to))
	 (to-loc (get-place-name-by-id (quantity-in to) places*))
	 (from (get-quantity-by-id (prediction-from prediction) quantities*))
	 (from-ent (quantity-name from))
	 (from-loc (get-place-name-by-id (quantity-in from) places*))
	 (direction (prediction-direction prediction)))
    (princ "  ")(princ (prediction-id prediction))
    (princ ": ")(princ to-ent) 
    (cond ((not (eq to-loc from-loc)) 
	   (princ " in the ")(princ to-loc)))
    (cond ((eq direction 'varies-ambiguously)
	   (princ " varies ambiguously"))
	  ((eq direction 'does-not-change)
	   (princ " does not change"))
	  (t (princ " ")(princ direction)))
    (princ " with ")(princ from-ent)
    (cond ((not (null from-loc))
	   (princ " in the ")(princ from-loc)))))

; EQUERY inputs a DEPENDENT id and an INDEPENDENT id, then creates
; and returns a structure that describes what happens to the first 
; when one varies the second. Possible answers are that the latter 
; increases with the former, that it decreases with the former, that 
; there is no effect, or that the prediction is ambiguous due to 
; conflicting paths between the variables. EQUERY deals with the
; effects of experimental variation, not change over time. 

(defun equery (to from) 
  (let* ((paths (find-exp-paths (quantity-id to) (quantity-id from)
				(list (quantity-id to)) 10))
	 (predictions (mapcar #'predict paths))
	 (pred (make-prediction :id (gen-name 'p)
				:to (quantity-id to)
				:from (quantity-id from)
				:paths predictions)))
    (cond ((null paths)
	   (setf (prediction-direction pred) 'does-not-change))
	  (t (cond ((same-predictions predictions)
		    (setf (prediction-direction pred) (caar predictions)))
		   (t (setf (prediction-direction pred) 'varies-ambiguously)))))
    (push pred predictions*)
    pred))

; TQUERY inputs a DEPENDENT id and an INDEPENDENT id for TIME, then 
; creates and returns a structure how the first quantity varies 
; as time increases. Possible answers are that it increases with 
; time, that it decreases with time, that it is constant, or that 
; the prediction is ambiguous due to conflicting influences. 

(defun tquery (to from) 
  (let* ((paths (find-time-paths (quantity-id to)
				 (list (quantity-id to)) 10))
	 (predictions (mapcar #'time-predict paths))
	 (pred (make-prediction :id (gen-name 'p)
				:to (quantity-id to)
				:from (quantity-id from)
				:paths predictions)))
    (cond ((null paths)
	   (setf (prediction-direction pred) 'does-not-change))
	  ((and (eq (length paths) 1)
		(null (caar predictions)))
	   (setf (prediction-direction pred) 'does-not-change))
	  (t (cond ((same-predictions predictions)
		    (setf (prediction-direction pred) (caar predictions)))
		   (t (setf (prediction-direction pred) 'varies-ambiguously)))))
    (push pred predictions*)
    pred))

(defun say-query-format (word)
  (princ "Queries take the form: ")
  (saycr "Does <quantity1> vary with <quantity2> in the <location> or")
  (saycr "Does <quantity1> in the <location1> vary with <quantity2> in the <location2>")
  (saycr "Your statement diverged at: ")
  (princ word)(terpri) nil)

; SAME-PREDICTIONS inputs a list of predictions (a direction and 
; its associated path. The function returns T if all of the non-null
; predictions involve the same direction. 

; (defun same-predictions (predictions) 
;   (cond ((null (cdr predictions)) t)
; 	((null (caar predictions))
; 	 (same-predictions (cdr predictions)))
; 	((not (eq (caar predictions) (caadr predictions))) nil)
; 	(t (same-predictions (cdr predictions)))))

(defun same-predictions (predictions)
  (cond ((null predictions) t)
	((null (caar predictions))
	 (same-predictions (cdr predictions)))
	(t (same-predictions-aux (caar predictions) (cdr predictions)))))

(defun same-predictions-aux (sign predictions)
  (cond ((null predictions) t)
	((null (caar predictions))
	 (same-predictions-aux sign (cdr predictions)))
	((not (eq (caar predictions) sign)) nil)
	(t (same-predictions-aux (caar predictions)
				 (cdr predictions)))))

(defun saycr (&rest content)
  (terpri)(mapc #'princ content) nil)

(defun say (&rest content)
  (mapc #'princ content) nil)

(defun say-quantity (quantity)
  (princ (quantity-name quantity))(princ " in the ")
  (princ (get-place-name-by-id (quantity-in quantity) places*)))

; FIND-EXP-PATHS inputs two quantity ids, FROM and TO, and returns
; all paths that, starting with TO, lead back to FROM. Each path 
; occurs in reverse order, chaining backward from the TO quantity. 
; 
; Note: Still need to extend to handle chaining back from names. 

(defun find-exp-paths (to from visited n)
  (let ((into (find-into to))
	(results nil))
    (do ((next (car into) (car into))) 
	((or (null into) (zerop n)) results)
; (terpri)(princ (claim-cause next))(princ "  ")(princ visited)
	(cond ((equal (claim-cause next) from)
	       (push (list next) results))
;	      ((equal (claim-cause next) to) nil)
	      ((member (claim-cause next) visited) nil)
	      (t (let ((subpaths (find-exp-paths (claim-cause next) from
						 (cons (claim-cause next) visited)
						 (1- n))))
		   (cond ((not (null subpaths))
			  (setq results
			     (append
			      (mapcar #'(lambda (x) (cons next x)) subpaths)
			      results)))))))
	(pop into))))

; FIND-TIME-PATHS inputs one quantity id, TO, and a depth N. It returns
; all paths that, starting with TO, lead back to either an exogenous
; variable or loop back to TO. Each path occurs in reverse order, 
; chaining backward from the TO quantity. 
; 
; Note: Still need to extend to handle chaining back from names. 

(defun find-time-paths (to visited n)
  (let ((into (find-into to))
	(results nil))
    (do ((next (car into) (car into))) 
	((or (null into) (zerop n)) results)
;	(cond ((equal (claim-cause next) start)
;	       (push (list next) results))
	(cond ((member (claim-cause next) visited)
	       (push (list next) results))
	      ((exogenous (claim-cause next))
	       (push (list next) results))
	      (t (let ((subpaths (find-time-paths (claim-cause next)
				     (cons (claim-cause next) visited)
				     (1- n))))
		   (cond ((not (null subpaths))
			  (setq results
			     (append
			      (mapcar #'(lambda (x) (cons next x)) subpaths)
			      results)))))))
	(pop into))))

; CONTAINED-IN returns T if the quantity ID occurs as the effect in
; any element of PATH. 

(defun contained-in (id path)
  (cond ((null path) nil)
	((eq (claim-effect (car path)) id) t)
	(t (contained-in id (cdr path)))))

; Exogenous returns T if the quantity ID has no causal links coming
; into it from other quantities. 

(defun exogenous (id)
  (null (find-into id)))

; FIND-INTO inputs an quantity structure TO and returns all elements
; of the list CLAIMS* that contain TO in its EFFECTS field. 
; 
; Note: Still need to extend to handle chaining back from names. 

(defun find-into (to)
  (let ((results nil)
	(links claims*))
    (do ((next (car links) (car links)))
	((null links) results)
	(cond ((equal (claim-effect next) to)
	       (push next results)))
	(pop links))))

(defun predict (path)
  (cons (predict-aux (claim-direction (car path)) (cdr path))
	path)) 

(defun predict-aux (current path)
  (cond ((null path) current)
	(t (let ((next (claim-direction (car path))))
	     (cond ((eq next 'increases)
		    (predict-aux current (cdr path)))
		   ((eq current 'increases) 
		    (predict-aux 'decreases (cdr path)))
		   (t (predict-aux 'increases (cdr path))))))))

(defun time-predict (path)
  (cons (time-predict-aux (reverse path)) path))

(defun time-predict-aux (path)
  (cond ((null path) nil)
	(t (let ((direction (claim-direction (car path)))
		 (etype (quantity-type
			  (get-quantity-by-id (claim-effect (car path))
					      quantities*))))
	     (cond ((eq etype 'transient)
		    (time-predict-aux (cdr path)))
		   (t (predict-aux direction (cdr path))))))))

; **********************************************************************
; Functions for comparing predictions to known facts
; **********************************************************************

(defun show-predict (facts)
  (cond ((null facts) (setq facts facts*))
	(t (setq facts
		 (mapcar #'(lambda (f) (get-fact-by-id f facts*)) facts))))
  (mapc #'show-predict-one (compare-to-facts facts))
  (princ "----------")(terpri))

(defun show-predict-one (pair)
  (let ((fact (car pair))
	(prediction (cdr pair)))
    (princ "----------")(terpri)
    (princ " Fact ")(princ (fact-id fact))(princ " and prediction ")
    (princ (prediction-id prediction))
    (cond ((eq (fact-direction fact) (prediction-direction prediction))
	   (princ " AGREE"))
	  (t (princ " DISAGREE")))
    (terpri)(show-fact fact)
    (terpri)(show-prediction prediction)
    (terpri)) nil)

(defun compare-to-facts (facts)
  (let ((results nil)(to-ent nil)(from-ent nil)(from-name nil))
    (do ((next (car facts) (car facts)))
	((null facts) results)
	(setq to-ent (get-quantity-by-id (fact-to next) quantities*))
	(setq from-ent (get-quantity-by-id (fact-from next) quantities*))
	(setq from-name
	      (get-quantity-name-by-id (fact-from next) quantities*))
	(cond ((eq from-name 'time)
	       (push (cons next (tquery to-ent from-ent)) results))
	      (t (push (cons next (equery to-ent from-ent)) results)))
	(pop facts))))

(defun show-explain (rest)
  (setq rest (retain-predictions rest))
  (cond ((not (null rest))
	 (setq rest
	       (mapcar #'(lambda (p)
			   (get-prediction-by-id p predictions*))
		       rest)))
	(t (setq rest (reverse predictions*))))
  (mapc #'show-explain-one rest) nil)

(defun retain-predictions (rest)
  (cond ((null rest) nil)
	((null (get-prediction-by-id (car rest) predictions*))
	 (princ (car rest))
	 (princ " is not a prediction")
	 (terpri)
	 (retain-predictions (cdr rest)))
	(t (cons (car rest) (retain-predictions (cdr rest))))))

(defun show-explain-one (prediction)
  (princ (prediction-id prediction))
  (princ ": ")
  (state-prediction prediction)
  (princ " because:")(terpri)
  (cond ((null (prediction-paths prediction))
	 (princ "    There are no causal paths from one to the other"))
	(t (princ "----------")
	   (mapc #'(lambda (e)
		     (terpri)(princ " Predicted effect: ")
		     (cond ((null (car e))(princ "none"))
			   (t (princ (car e))))
		     (show-explain-path (cdr e))
		     (terpri)(princ "----------"))
		 (prediction-paths prediction))))
  (terpri) nil)

(defun state-prediction (prediction)
  (let* ((to (get-quantity-by-id (prediction-to prediction) quantities*))
	 (to-name (quantity-name to))
	 (to-loc (get-place-name-by-id (quantity-in to) places*))
	 (from (get-quantity-by-id (prediction-from prediction) quantities*))
	 (from-name (quantity-name from))
	 (from-loc (get-place-name-by-id (quantity-in from) places*)))
    (princ to-name)
    (cond ((not (eq to-loc from-loc))
	   (princ " in the ")(princ to-loc)))
    (princ " ")(princ (prediction-direction prediction))
    (princ " with ")(princ from-name)
    (cond ((not (null from-loc))
	   (princ " in the ")(princ from-loc)))))

(defun show-explain-path (path)
  (cond ((not (null path))
	 (show-link (car path))
	 (show-explain-path (cdr path)))))

(defun show-link (claim)
  (let* ((to nil)(to-name nil)(to-loc nil)
	 (from (get-quantity-by-id (claim-cause claim) quantities*))
	 (from-name (quantity-name from))
	 (from-loc (get-place-name-by-id (quantity-in from) places*)))
    (cond ((setq to (get-quantity-by-id (claim-effect claim) quantities*))
	   (setq to-name (quantity-name to))
	   (setq to-loc (get-place-name-by-id (quantity-in to) places*)))
	  (t (setq to (get-claim-by-id (claim-effect claim) claims*))
	     (setq to-name (claim-id to))))
    (terpri)(princ "  ")(princ to-name)
    (cond ((and (not (null to-loc))
		(not (eq to-loc from-loc)))
	   (princ " in the ")(princ to-loc)))
    (princ " ")(princ (claim-direction claim))
    (princ " with ")(princ from-name)
    (cond ((not (null from-loc))
	   (princ " in the ")(princ from-loc)))))

; **********************************************************************
; Functions for removing, disabling, and enabling elements
; **********************************************************************

; REMOVE-CONTENT removes all items specified in REST unless it is NIL, 
; in which case the function removes all places, quantities, claims, 
; facts, and predictions. 

(defun remove-content (rest)
  (cond ((null rest)
	 (setq places* nil)
	 (setq quantities* nil)
	 (push (make-quantity :id 'q0 :name 'time) quantities*)
	 (setq claims* nil) 
	 (setq facts* nil) 
	 (setq predictions* nil))
	(t (mapc #'remove-struct-by-id rest))))

(defun remove-struct-by-id (id)
  (let ((struct nil))
    (cond ((setq struct (get-place-by-id id places*))
	   (setq places* (remove struct places*)))
	  ((setq struct (get-quantity-by-id id quantities*))
	   (setq quantities* (remove struct quantities*)))
	  ((setq struct (get-claim-by-id id claims*))
	   (setq claims* (remove struct claims*)))
	  ((setq struct (get-fact-by-id id facts*))
	   (setq facts* (remove struct facts*)))
;	  ((setq struct (get-prediction-by-id id predictions*))
;	   (setq predictions* (remove struct predictions*)))
	  (t nil))))

(defun disable-content (rest)
  (mapc #'disable-struct-by-id rest))

(defun disable-struct-by-id (id)
  (let ((struct nil))
    (cond ((setq struct (get-place-by-id id places*))
	   (say "You can only disable claims and facts.")(terpri))
	  ((setq struct (get-quantity-by-id id quantities*))
	   (say "You can only disable claims and facts.")(terpri))
	  ((setq struct (get-claim-by-id id claims*))
	   (setq claims* (remove struct claims*))
	   (push struct disabled-claims*))
	  ((setq struct (get-fact-by-id id facts*))
	   (setq facts* (remove struct facts*))
	   (push struct disabled-facts*))
;	  ((setq struct (get-prediction-by-id id predictions*))
;	   (say "You can only disable claims and facts.")(terpri))
	  (t nil))))

(defun enable-content (rest)
  (mapc #'enable-struct-by-id rest))

(defun enable-struct-by-id (id)
  (let ((struct nil))
    (cond ((setq struct (get-place-by-id id places*))
	   (say "You can only enable claims and facts.")(terpri))
	  ((setq struct (get-quantity-by-id id quantities*))
	   (say "You can only enable claims and facts.")(terpri))
	  ((setq struct (get-claim-by-id id disabled-claims*))
	   (setq disabled-claims* (remove struct disabled-claims*))
	   (push struct claims*))
	  ((setq struct (get-fact-by-id id disabled-facts*))
	   (setq disabled-facts* (remove struct disabled-facts*))
	   (push struct facts*))
	  ((setq struct (get-claim-by-id id claims*))
	   (say "That claim is already enabled.")(terpri))
	  ((setq struct (get-fact-by-id id facts*))
	   (say "That fact is already enabled.")(terpri))
;	  ((setq struct (get-prediction-by-id id predictions*))
;	   (say "You can only enable claims and facts.")(terpri))
	  (t nil))))

; **********************************************************************
; Functions for loading and saving content
; **********************************************************************

(defun load-content (file)
  (setq loading* t)
  (with-open-file (stream file
			  :direction :input
			  :if-does-not-exist nil)
    (do* ((input (input-from-file stream) (input-from-file stream))
	  (command (car input) (car input))
	  (rest (cdr input) (cdr input)))
	 ((member (car input) '(quit q exit bye end halt done)))
	 (cond ((or (null command) (eq '% (car input))) nil)
	       ((eq command 'place)(create-place rest))
	       ((eq command 'transient)(create-quantity rest 'transient))
	       ((eq command 'stable)(create-quantity rest 'stable))
	       ((eq command 'claim)(create-claim rest))
	       ((eq command 'fact)(create-fact rest))
	       ((eq command 'does)(ask-query rest))
	       ((eq command 'note)(add-note rest))
	       ((eq command 'show)(show-content rest))
	       ((eq command 'predict)(show-predict rest))
	       ((eq command 'explain)(show-explain rest))
	       ((eq command 'remove)(remove-content rest))
	       ((eq command 'disable)(disable-content rest))
	       ((eq command 'enable)(enable-content rest))
	       ((eq command 'group)(create-group rest))
	       ((eq command 'ungroup)(uncreate-group rest))
	       ((eq command 'load)(mapc #'load-content rest))
	       ((eq command 'save)(save-content rest))
	       ((eq command 'help)(provide-help rest))
	       (t (say-not-command command)))))
  (say file " loaded")(terpri)
  (setq loading* nil))

; **********************************************************************
; Functions for loading and saving content
; **********************************************************************

(defun provide-help (types)
  (cond ((null types)
	 (princ "Available commands:")
	 (terpri)(princ "----------")(terpri)
	 (setq types commands*)))
  (do ((next (car types) (car types)))
      ((null types) nil)
      (cond ((not (member next commands*))
	     (say-not-command next))
	    (t (help-with next)))
      (terpri)
      (pop types)))

(defun help-with (command)
  (cond ((eq command 'place)
	 (princ "Place: Specifies a location in the system")
	 (saycr " Syntax: Place <location> or Place <location1> in the <location2>"))
	((eq command 'transient)
	 (princ "Transient: Specifies a transient quantity in some location")
	 (saycr " Syntax: Transient <quantity> in the <location>"))
	((eq command 'stable)
	 (princ "Stable: Specifies a stable quantity in some location")
	 (saycr " Syntax: Stable <quantity> in the <location>"))
	((eq command 'claim)
	 (princ "Claim: Specifies a hypothesized causal relation between two quantities")
	 (saycr " Syntax: Claim <quantity1> <relation> with <quantity2> in the <location> or")
	 (saycr "         Claim <quantity1> in the <loc1> <relation> <quantity2> with in the <loc2>")
	 (saycr "         where <relation> may be increases or decreases"))
	((eq command 'fact)
	 (princ "Fact: Specifies an observed, empirical relation between two quantities")
	 (saycr " Syntax: Fact <quantity1> <relation> with <quantity2> in the <location> or")
	 (saycr "         Fact <quantity1> in the <loc1> <relation> with <quantity2> in the <loc2>")
	 (saycr "         where <relation> may be increases, decreases, does-not-vary"))
	((eq command 'show)
	 (princ "Show: Displays current knowledge about the system")
	 (saycr " Syntax: Show places quantities claims facts predictions")
	 (saycr "         or some subset of these content types")
	 (saycr "         Lacking arguments, it display all types of content"))
	((eq command 'does)
	 (princ "Does: Asks what relation the claims predict between two quantities")
	 (saycr " Syntax: Does <quantity1> vary with <quantity2> in the <location> or")
	 (saycr "         Does <quantity1> in the <loc1> vary with <quantity2> in the <loc2>")
	 (saycr "         Answers are increases, decreases, does not vary, or varies ambiguously"))
	((eq command 'predict)
	 (princ "Predict: Shows the predictions that correspond to a known set of facts")
	 (saycr " Syntax: Predict <fact-id1> <fact-id2> ... or simply Predict")
	 (saycr "         Lacking arguments, it makes predictions for all facts"))
	((eq command 'explain)
	 (princ "Explain: Provides causal explanations for the given predictions")
	 (saycr " Syntax: Explain <prediction-id1> <prediction-id2> ... or simply Explain")
	 (saycr "         Lacking arguments, it shows explanations for all predictions"))
	((eq command 'disable)
	 (princ "Disable: Temporarily suspends claims or facts from consideration")
	 (saycr " Syntax: Disable <claim1> <claim2> <fact3> ...")
	 (saycr "         Disabled contents are not used by Does, Predict, or Show"))
	((eq command 'enable)
	 (princ "Enable: Reactivates Claims or facts that have been disabled earlier")
	 (saycr " Syntax: Enable <claim1> <claim2> <fact3> ..."))
	((eq command 'remove)
	 (princ "Remove: Permanently removes claims or facts from consideration")
	 (saycr " Syntax: Remove <claim1> <claim2> <fact3> ...")
	 (saycr "         Removed contents are not used by Does, Predict, or Show"))
	((eq command 'load)
	 (princ "Load: Input a file that contains knowledge about a system")
	 (saycr " Syntax: Load \"<file-name>\", where <file-name> must be in double quotes")
	 (saycr "         The file's contents are added to existing knowledge"))
	((eq command 'save)
	 (princ "Save: Output current knowledge about a system to a file")
	 (saycr " Syntax: Save \"<file-name>\", where <file-name> must be in double quotes")
	 (saycr "         The file receives all existing knowledge about the system"))
	((eq command 'help)
	 (princ "Help: Displays information about available commands")
	 (saycr " Syntax: Help <command1> <command2> ... or simply Help")
	 (saycr "         Lacking arguments, it gives help on all commands"))
	((eq command 'quit)
	 (princ "Quit: Exits the modeling environment"))))

; **********************************************************************
; Utility functions for reading user input 
; These are borrowed (I think) from early code on the Adaptive Place
; Advisor by Jeff Shrager. 
; **********************************************************************

(defun input-from-file (stream)
  (let ((input (read-line stream nil)))
    (cond ((not (equal "" input))
           (parse-string input)))))

; Absolutely minimal I/O for the top loop.

; (defun prompt-and-input ()
;   (princ "> ")(parse-string (read-line)))

(defun prompt-and-input ()
  (princ "> ")
  (let ((input (read-line)))
    (cond ((not (equal "" input))
           (parse-string input)))))

(defun parse-string (s)
  (mapcar #'read-from-string (strip-front-blanks (parse-to-substrings s))))

(defun strip-front-blanks (s)
  (cond ((not (equal "" (car s))) s)
	(t (strip-front-blanks (cdr s)))))

; This is like the general parse-string util, but it doesn't make 
; atoms of everything that's read.  Instead, it just leaves them 
; all as strings.

(defun parse-to-substrings (s &aux ss)
  (let ((stop (length s))
        (w ""))
    (do ((i 0 (incf i))
         (c (subseq s 0 1)
            (if (= i stop)
                (subseq s i)
                (subseq s i (1+ i)))
         ))
        ((= i stop))
      (if (equal " " c)
          (progn (push w ss)
                 (setq w ""))
          (setq w (format nil "~A~A" w c)))
      )
    (reverse (cons w ss))
    ))

(push (make-quantity :id 'q0 :name 'time) quantities*)

; (princ "Type (run) to enter the modeling environment")
; (terpri)
